home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / sort < prev    next >
Text File  |  1993-04-02  |  4KB  |  152 lines
  1. ;;; File   : sort.scm
  2. ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
  3. ;;; Updated: 11 June 1991
  4. ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
  5. ;;; Defines: sorted?, merge, merge!, sort, sort!
  6.  
  7. ;;; (sorted? sequence less?)
  8. ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
  9. ;;; such that for all 1 <= i <= m,
  10. ;;;    (not (less? (list-ref list i) (list-ref list (- i 1)))).
  11.  
  12. (define (sort:sorted? seq less?)
  13.     (cond
  14.     ((null? seq)
  15.         #t)
  16.     ((vector? seq)
  17.         (let ((n (vector-length seq)))
  18.         (if (<= n 1)
  19.             #t
  20.             (do ((i 1 (+ i 1)))
  21.             ((or (= i n)
  22.                  (less? (vector-ref seq (- i 1))
  23.                          (vector-ref seq i)))
  24.                 (= i n)) )) ))
  25.     (else
  26.         (let loop ((last (car seq)) (next (cdr seq)))
  27.         (or (null? next)
  28.             (and (not (less? (car next) last))
  29.              (loop (car next) (cdr next)) )) )) ))
  30.  
  31.  
  32. ;;; (merge a b less?)
  33. ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
  34. ;;; and returns a new list in which the elements of a and b have been stably
  35. ;;; interleaved so that (sorted? (merge a b less?) less?).
  36. ;;; Note:  this does _not_ accept vectors.  See below.
  37.  
  38. (define (sort:merge a b less?)
  39.     (cond
  40.     ((null? a) b)
  41.     ((null? b) a)
  42.     (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
  43.         ;; The loop handles the merging of non-empty lists.  It has
  44.         ;; been written this way to save testing and car/cdring.
  45.         (if (less? y x)
  46.         (if (null? b)
  47.             (cons y (cons x a))
  48.             (cons y (loop x a (car b) (cdr b)) ))
  49.         ;; x <= y
  50.         (if (null? a)
  51.             (cons x (cons y b))
  52.             (cons x (loop (car a) (cdr a) y b)) )) )) ))
  53.  
  54.  
  55. ;;; (merge! a b less?)
  56. ;;; takes two sorted lists a and b and smashes their cdr fields to form a
  57. ;;; single sorted list including the elements of both.
  58. ;;; Note:  this does _not_ accept vectors.
  59.  
  60. (define (sort:merge! a b less?)
  61.     (define (loop r a b)
  62.     (if (less? (car b) (car a))
  63.         (begin
  64.         (set-cdr! r b)
  65.         (if (null? (cdr b))
  66.             (set-cdr! b a)
  67.             (loop b a (cdr b)) ))
  68.         ;; (car a) <= (car b)
  69.         (begin
  70.         (set-cdr! r a)
  71.         (if (null? (cdr a))
  72.             (set-cdr! a b)
  73.             (loop a (cdr a) b)) )) )
  74.     (cond
  75.     ((null? a) b)
  76.     ((null? b) a)
  77.     ((less? (car b) (car a))
  78.         (if (null? (cdr b))
  79.         (set-cdr! b a)
  80.         (loop b a (cdr b)))
  81.         b)
  82.     (else ; (car a) <= (car b)
  83.         (if (null? (cdr a))
  84.         (set-cdr! a b)
  85.         (loop a (cdr a) b))
  86.         a)))
  87.  
  88.  
  89.  
  90. ;;; (sort! sequence less?)
  91. ;;; sorts the list or vector sequence destructively.  It uses a version
  92. ;;; of merge-sort invented, to the best of my knowledge, by David H. D.
  93. ;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
  94. ;;; adapted it to work destructively in Scheme.
  95.  
  96. (define (sort:sort! seq less?)
  97.     (define (step n)
  98.     (cond
  99.         ((> n 2)
  100.         (let* ((j (quotient n 2))
  101.                (a (step j))
  102.                (k (- n j))
  103.                (b (step k)))
  104.             (sort:merge! a b less?)))
  105.         ((= n 2)
  106.         (let ((x (car seq))
  107.               (y (cadr seq))
  108.               (p seq))
  109.             (set! seq (cddr seq))
  110.             (if (less? y x) (begin
  111.             (set-car! p y)
  112.             (set-car! (cdr p) x)))
  113.             (set-cdr! (cdr p) '())
  114.             p))
  115.         ((= n 1)
  116.         (let ((p seq))
  117.             (set! seq (cdr seq))
  118.             (set-cdr! p '())
  119.             p))
  120.         (else
  121.         '()) ))
  122.     (if (vector? seq)
  123.     (let ((n (vector-length seq)))
  124.         (set! seq (vector->list seq))
  125.         (do ((p (step n) (cdr p))
  126.          (i 0 (+ i 1)))
  127.         ((null? p) vector)
  128.         (vector-set! vector i (car p)) ))
  129.     ;; otherwise, assume it is a list
  130.     (step (length seq)) ))
  131.  
  132.  
  133. ;;; (sort sequence less?)
  134. ;;; sorts a vector or list non-destructively.  It does this by sorting a
  135. ;;; copy of the sequence.  My understanding is that the Standard says
  136. ;;; that the result of append is always "newly allocated" except for
  137. ;;; sharing structure with "the last argument", so (append x '()) ought
  138. ;;; to be a standard way of copying a list x.
  139.  
  140. (define (sort:sort seq less?)
  141.     (if (vector? seq)
  142.     (list->vector (sort:sort! (vector->list seq) less?))
  143.     (sort:sort! (append seq '()) less?)))
  144.  
  145. ;;; eof
  146.  
  147. (define sorted? sort:sorted?)
  148. (define merge sort:merge)
  149. (define merge! sort:merge!)
  150. (define sort sort:sort)
  151. (define sort! sort:sort!)
  152.